C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.3
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.3
C---------------------------------------------------------
        PROGRAM ISTAN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.3
C---------------------------------------------------------
        COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
        INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
 
        SAVE /IO/
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.3
C---------------------------------------------------------
C                  KEYWORD ID VARIABLES
      COMMON / KEYSC   /    KAGOG,       KAIFG,       KASMTG,
     *         KASSNG,      KBACKG,      KBIFG,       KBLOKG,
     *         KCALLG,      KCFUNG,      KCGOG,       KCHARG,
     *         KCLOSG,      KCMPXG,      KCOMNG,      KCONTG,
     *         KDATAG,      KDBLEG,      KDFUNG,      KDIMNG,
     *         KDOG,        KELSEG,      KELSFG,      KENDFG,
     *         KENDG,       KENDIG,      KEQIVG,      KEXTLG,
     *         KFORMG,      KIFUNG,      KIMPLG,      KINQRG,
     *         KINSCG,      KINTEG,      KLFUNG,      KLIFG,
     *         KLOGCG,      KNONEG,      KNTRYG,      KOPENG,
     *         KPARAG,      KPAUSG,      KPRNTG,      KPROGG,
     *         KREADG,      KREALG,      KRETNG,      KRFUNG,
     *         KSAVEG,      KSFUNG,      KSTOPG,      KSUBRG,
     *         KUFUNG,      KUGOG,       KWINDG,      KWRITG,
     *         KXFUNG,      LASRTG,      LCMNTG,      LERRG,
     *         LLINEG,      LSTMTG
 
        INTEGER KAGOG,KAIFG,KASMTG,KASSNG,KBACKG,KBIFG,KBLOKG,KCALLG,
     +          KCFUNG,KCGOG,KCHARG,KCLOSG,KCMPXG,KCOMNG,KCONTG,KDATAG,
     +          KDBLEG,KDFUNG,KDIMNG,KDOG,KELSEG,KELSFG,KENDFG,KENDG,
     +          KENDIG,KEQIVG,KEXTLG,KFORMG,KIFUNG,KIMPLG,KINQRG,KINSCG,
     +          KINTEG,KLFUNG,KLIFG,KLOGCG,KNONEG,KNTRYG,KOPENG,KPARAG,
     +          KPAUSG,KPRNTG,KPROGG,KREADG,KREALG,KRETNG,KRFUNG,KSAVEG,
     +          KSFUNG,KSTOPG,KSUNRG,KUUNG,KUGOG,KWINDG,KWRITG,KXFUNG,
     +          LASRTG,LCMNTG,LERRG,LLINEG,LSTMTG
        INTEGER KUFUNG,KSUBRG
 
        SAVE /KEYSC/
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.3
C---------------------------------------------------------
C                  MAIN INTEGER STORAGE ARRAYS
C MAXLBG = Maximum number of DO statement labels per routine
        INTEGER MAXLBG
        PARAMETER(MAXLBG=100)
        COMMON / WORKC   /  IABEG(201),  ICRTNG(200), IPCNTG(75),
     *         IRCNTG(75),  ISBEG(201),  ISCNTG(75),  INSTG(250),
     *         KEXECG(75),  LABG(2,MAXLBG), KTOKG(81)
        INTEGER IABEG,ICRTNG,IPCNTG,IRCNTG,ISBEG,ISCNTG,INSTG,
     +          KEXECG,LABG,KTOKG
        SAVE /WORKC/
 
        INTEGER TKNPTH(81),CMTPTH(81),INSPTH(81),
     +          STSPTH(81),TKOPTH(81),CMOPTH(81),
     +          SUMPTH(81),OPTSTR(134),SCRPTH(11),
     +          IODTKN,IODCMT,IODTKO,IODCMO,I
 
        INTEGER GETARG,OPEN,CREATE,ZTKGTI,ZTKPTI
        EXTERNAL GETARG,OPEN,CREATE,ZINIT,ZQUIT,ERROR,CLOSE,ZMESS,
     +           REMOVE,ZTKGTI,ZTKPTI
 
        DATA SCRPTH/97,110,108,115,99,114,46,116,109,
     +112,129/
 
        CALL ZINIT
 
        IF (GETARG(1,TKNPTH,81).EQ.-100) CALL NAMES(1,TKNPTH)
        IF (GETARG(2,CMTPTH,81).EQ.-100) CALL NAMES(2,CMTPTH)
        IF (GETARG(3,INSPTH,81).EQ.-100) CALL NAMES(3,INSPTH)
        IF (GETARG(4,STSPTH,81).EQ.-100) CALL NAMES(4,STSPTH)
        IF (GETARG(5,TKOPTH,81).EQ.-100) CALL NAMES(5,TKOPTH)
        IF (GETARG(6,CMOPTH,81).EQ.-100) CALL NAMES(6,CMOPTH)
        IF (GETARG(7,SUMPTH,81).EQ.-100) CALL NAMES(7,SUMPTH)
        IF (GETARG(8,OPTSTR,134).EQ.-100) CALL NAMES(8,OPTSTR)
 
        IODTKN=OPEN(TKNPTH,0)
        IF (IODTKN.EQ.-1) CALL ERROR('Can''t open token input')
        IODCMT=OPEN(CMTPTH,0)
        IF (IODCMT.EQ.-1) CALL ERROR('Can''t open comment input')
        IODSTS=CREATE(STSPTH,1)
        IF (IODSTS.EQ.-1)
     +      CALL ERROR('Can''t create statement summary file')
        IODTKO=CREATE(TKOPTH,1)
        IF (IODTKO.EQ.-1) CALL ERROR('Can''t create token output')
        IODCMO=CREATE(CMOPTH,1)
        IF (IODCMO.EQ.-1) CALL ERROR('Can''t create comment output')
        IODSCR=CREATE(SCRPTH,2)
        IF (IODSCR.EQ.-1) CALL ERROR('Can''t create scratch output')
 
C Initialise the token input/output streams
 
        TKIDES=ZTKGTI(1,IODTKN,IODCMT)
        TKODES=ZTKPTI(1,IODTKO,IODCMO)
 
C Process user-specified options
 
        CALL DOOPT(OPTSTR)
        DO 100 I=9,10
            IF (GETARG(I,OPTSTR,134).NE.-100) CALL DOOPT(OPTSTR)
 100    CONTINUE
 
C Initialise pre-processor variables
        CALL INITSS
 
C Input source program and perform annotation
C and instrumentation functions at statement level.
        CALL PASS1S
 
C Close input now we have finished with it, to keep the number of files
C simultaneously open as low as possible (not very low!)
        CALL CLOSE(IODTKN)
        CALL CLOSE(IODCMT)
 
C Perform final instrumentation functions at program level
        IODINS=CREATE(INSPTH,1)
        IF (IODINS.EQ.-1)
     +      CALL ERROR('Can''t create instrumented source file')
        CALL PASS2S
 
C Get rid of scratch file
        CALL CLOSE(IODSCR)
        CALL REMOVE(SCRPTH)
 
C Create summary listing
        IODSUM=CREATE(SUMPTH,1)
        IF (IODSUM.EQ.-1) CALL ERROR('Can''t create summary output')
        CALL SUMS(IPCNTG)
 
        IF (IPCNTG(LERRG).EQ.0) THEN
            CALL ZMESS('[ISTAN Normal Termination]',2)
            CALL ZQUIT(-2)
        ELSE
            CALL ZCHOUT('[ISTAN Terminated, ',2)
            CALL ZPTINT(IPCNTG(LERRG),1,2)
            CALL ZMESS(' errors]',2)
            CALL ZQUIT(-1)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       N A M E S   -   Input missing argument from user
C
 
        SUBROUTINE NAMES(NUMBER,STRING)
        INTEGER NUMBER,STRING(*)
 
        INTEGER I,PROMPT(34,8)
 
        INTEGER ZGTCMD
        EXTERNAL ZPRMPT,ZGTCMD
 
C "Input token stream: "
C "Input comment stream: "
C "Output instrumented source code: "
C "Output statement summary: "
C "Output annotated token stream: "
C "Output annotated comment stream: "
C "Output summary file: "
C "Options: "
 
        DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,116,
     +111,107,101,110,32,115,116,114,101,97,109,58,
     +32,129/,
     +       (PROMPT(I,2),I=1,23)/73,110,112,117,116,32,99,
     +111,109,109,101,110,116,32,115,116,114,101,97,109,
     +58,32,129/,
     +       (PROMPT(I,3),I=1,34)/79,117,116,112,117,116,32,
     +105,110,115,116,114,117,109,101,110,116,101,100,32,
     +115,111,117,114,99,101,32,99,111,100,101,58,32,
     +129/,
     +       (PROMPT(I,4),I=1,27)/79,117,116,112,117,116,32,
     +115,116,97,116,101,109,101,110,116,32,115,117,109,
     +109,97,114,121,58,32,129/,
     +       (PROMPT(I,5),I=1,32)/79,117,116,112,117,116,32,
     +97,110,110,111,116,97,116,101,100,32,116,111,107,
     +101,110,32,115,116,114,101,97,109,58,32,129/,
     +       (PROMPT(I,6),I=1,34)/79,117,116,112,117,116,32,
     +97,110,110,111,116,97,116,101,100,32,99,111,109,
     +109,101,110,116,32,115,116,114,101,97,109,58,32,
     +129/
        DATA (PROMPT(I,7),I=1,22)/79,117,116,112,117,116,32,
     +115,117,109,109,97,114,121,32,102,105,108,101,58,
     +32,129/,
     +       (PROMPT(I,8),I=1,10)/79,112,116,105,111,110,115,
     +58,32,129/
 
        CALL ZPRMPT(PROMPT(1,NUMBER))
        IF (ZGTCMD(STRING,0).EQ.-1) CALL ERROR('ZGTCMD failed')
 
        END
C ----------------------------------------------------------------------
C
C       D O O P T   -   Decode the option string
C
 
        SUBROUTINE DOOPT(OPTSTR)
        INTEGER OPTSTR(134)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.3
C---------------------------------------------------------
C Filenames
        COMMON/ANFNAM/IHSTFN,OHSTFN,LSTFN,ITRAFN,OTRAFN,RUNFN
        CHARACTER*81 IHSTFN,OHSTFN,LSTFN,ITRAFN,OTRAFN,RUNFN
        SAVE /ANFNAM/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.3
C---------------------------------------------------------
C                  LOGICAL VARIABLES
      COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
     *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
     *         HISTG,       IEOFG,       IFDOG,       INSRTG,
     *         MAING,       SEGMTG,      STOPG,       TRACEG,
     *         TREEG
      LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
     *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
     *         IEOFG,       IFDOG,       INSRTG,      MAING,
     *         SEGMTG,      STOPG,       TRACEG,      TREEG
 
        SAVE /LOGIC/
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.3
C---------------------------------------------------------
C Option Settings
        COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
     +                 MTREQG,TIEG,ITRUNG
 
        INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
     +          ITRUNG
        LOGICAL TIEG
 
        SAVE /OPTSC/
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.3
C---------------------------------------------------------
        COMMON/ANVNAM/VNAMEG
        CHARACTER*5 VNAMEG
        SAVE/ANVNAM/
 
        INTEGER OPTTBL(63),STRING(134),POINT,PTR
        INTEGER LHS(134),RHS(134),OPTION,OPTARG
        LOGICAL LSTSET,TRISET,TROSET,INIT
 
        SAVE OPTTBL,LSTSET,TRISET,TROSET,INIT
 
        INTEGER GETWRD,ZKWLUK,ZSPLIT,LENGTH
        EXTERNAL GETWRD,ZCHOUT,PUTLIN,ZMESS,ZKWLUK,ZSPLIT,SCOPY,ZITOF,
     +           LENGTH
 
        DATA LSTSET,TRISET,TROSET/3*.FALSE./
        DATA OPTTBL/7,
     +      97,115,115,101,114,116,105,111,110,115,129,
     +      104,105,115,116,111,114,121,129,
     +      108,105,115,116,105,110,103,129,
     +      114,117,110,100,97,116,97,129,
     +      116,105,101,95,99,111,110,102,111,114,
     +109,105,110,103,129,
     +      116,114,97,99,101,129,
     +      118,110,97,109,101,129/
        DATA INIT/.TRUE./
 
C First initialise option values
 
        IF (INIT) THEN
            LSTFN=' '
            IHSTFN=' '
            OHSTFN=' '
            ITRAFN=' '
            OTRAFN=' '
            RUNFN=' '
            ITRUNG=0
            INIT=.FALSE.
        END IF
 
        POINT=1
 
 100    IF (GETWRD(OPTSTR,POINT,STRING).EQ.0) RETURN
        IF (ZSPLIT(STRING,LHS,RHS).NE.-2) THEN
            CALL SCOPY(STRING,1,LHS,1)
            RHS(1)=129
        END IF
        OPTION=ZKWLUK(LHS,OPTTBL)
        IF (OPTION.LE.0) THEN
            IF (OPTION.EQ.0) CALL ZCHOUT('%ISTAN - Ambiguous',1)
            IF (OPTION.EQ.-1)  CALL ZCHOUT('%ISTAN - Unknown',1)
            CALL ZCHOUT(' Option "',1)
            CALL PUTLIN(LHS,1)
            CALL ZMESS('" Ignored',1)
        ELSE IF (OPTION.EQ.1) THEN
            ASSRTG=.TRUE.
        ELSE IF (OPTION.EQ.2) THEN
            HISTG=.TRUE.
            IF (RHS(1).NE.129) THEN
                PTR=1
                CALL OPTFN(RHS,PTR,IHSTFN,INHSTG)
                IF (RHS(PTR).NE.129)
     +              CALL OPTFN(RHS,PTR,OHSTFN,ITHSTG)
            END IF
        ELSE IF (OPTION.EQ.3) THEN
            IF (RHS(1).EQ.129) THEN
                CALL REMARK(
     +              '%ISTAN - Missing argument to the LISTING option')
            ELSE
                PTR=1
                CALL OPTFN(RHS,PTR,LSTFN,ITLSTG)
                LSTSET=.TRUE.
            END IF
        ELSE IF (OPTION.EQ.4) THEN
            IF (RHS(1).EQ.129) THEN
                CALL REMARK(
     +              '%ISTAN - Missing argument to the RUNDATA option')
            ELSE
                PTR=1
                CALL OPTFN(RHS,PTR,RUNFN,ITRUNG)
                IF (RHS(PTR).NE.129) THEN
                    ITRUNG=0
                    CALL REMARK(
     +                  '%ISTAN - Invalid argument to RUNDATA option')
                END IF
            END IF
        ELSE IF (OPTION.EQ.5) THEN
            TIEG=.TRUE.
            IF (RHS(1).NE.129) CALL REMARK(
     +          '%ISTAN - Argument to TIE_CONFORMING option ignored')
            IF (.NOT.LSTSET) ITLSTG=1
            IF (.NOT.TRISET) INTRAG=0
            IF (.NOT.TROSET) ITTRAG=1
        ELSE IF (OPTION.EQ.6) THEN
            TRACEG=.TRUE.
            IF (RHS(1).NE.129) THEN
                PTR=1
                CALL OPTFN(RHS,PTR,ITRAFN,INTRAG)
                TRISET=.TRUE.
                IF (RHS(PTR).NE.129) THEN
                    CALL OPTFN(RHS,PTR,OTRAFN,ITTRAG)
                    TROSET=.TRUE.
                END IF
            END IF
        ELSE
C OPTION=7 (VNAME)
            IF (RHS(1).EQ.129) THEN
                CALL REMARK(
     +              '%ISTAN - Missing argument to the VNAME option')
            ELSE IF (LENGTH(RHS).NE.5) THEN
                CALL REMARK(
     +          '%ISTAN - The length of the VNAME argument must be 5')
            ELSE
                CALL ZITOF(RHS,1,5,VNAMEG,.FALSE.)
            END IF
        END IF
        GOTO 100
        END
C ----------------------------------------------------------------------
C
C       O P T F N   -   Process option file names
C
 
        SUBROUTINE OPTFN(STRING,POINT,NAME,UNIT)
        INTEGER STRING(*),POINT,UNIT
        CHARACTER*81 NAME
 
        INTEGER I
 
        INTEGER CTOI
        CHARACTER ZCITOC
        EXTERNAL ZCITOC,SKIPBL,REMARK,CTOI
 
        IF (STRING(POINT).GE.48 .AND. STRING(POINT).LE.57) THEN
            UNIT=CTOI(STRING,POINT)
            CALL SKIPBL(STRING,POINT)
            IF (STRING(POINT).EQ.61) THEN
                POINT=POINT+1
                CALL SKIPBL(STRING,POINT)
            ELSE
                GOTO 666
            END IF
        END IF
        IF (STRING(POINT).EQ.42) THEN
            NAME=''''
            POINT=POINT+1
            CALL SKIPBL(STRING,POINT)
            IF (STRING(POINT).NE.44 .AND. STRING(POINT).NE.129)
     +          CALL REMARK('End of option expected')
        ELSE IF (STRING(POINT).EQ.39) THEN
            I=1
            NAME=' '
 100        NAME(I:I)=ZCITOC(STRING(POINT+I),NAME(I:I))
            I=I+1
            IF (STRING(POINT+I).NE.39 .AND.
     +          STRING(POINT+I).NE.129) GOTO 100
            POINT=POINT+I
            IF (STRING(POINT).EQ.39) POINT=POINT+1
        ELSE
            CALL REMARK('Invalid argument to option')
        END IF
 666    IF (STRING(POINT).EQ.44) POINT=POINT+1
 
        END
